home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / predef1.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  43KB  |  1,821 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /*    +---------------------------------------------------+
  10.       |                                                   |
  11.       |          I N T E R P     P R E D E F S            |
  12.       |                  (C Version)                      |
  13.       |                                                   |
  14.       |   Adapted From Low Level SETL version written by  |
  15.       |                                                   |
  16.       |                  Monte Zweben                     |
  17.       |               Philippe Kruchten                   |
  18.       |               Jean-Pierre Rosen                   |
  19.       |                                                   |
  20.       |    Original High Level SETL version written by    |
  21.       |                                                   |
  22.       |                   Clint Goss                      |
  23.       |               Tracey M. Siesser                   |
  24.       |               Bernard D. Banner                   |
  25.       |               Stephen C. Bryant                   |
  26.       |                  Gerry Fisher                     |
  27.       |                                                   |
  28.       |              C version written by                 |
  29.       |                                                   |
  30.       |               Robert B. K. Dewar                  |
  31.       |                                                   |
  32.       +---------------------------------------------------+ */
  33.  
  34. /* This module contains routines for the implementation of some of
  35.  * the predefined Ada packages and routines, namely SEQUENTIAL_IO,
  36.  * DIRECT_IO, TEXT_IO, and CALENDAR. Part 1 contains the PREDEF
  37.  * routine which executes a predefined operation.
  38. */
  39.  
  40. #include <stdlib.h>
  41. #include <setjmp.h>
  42. #include <string.h>
  43. #include "ipredef.h"
  44. #include "intbp.h"
  45. #include "intcp.h"
  46. #include "predefp.h"
  47.  
  48. /*
  49.  * Environment variable to save stack pointer for PREDEF_RAISE. On entry to
  50.  * PREDEF, raise_env saves the stack environment (using set_jmp). If an Ada
  51.  * exception is signalled, then the PREDEF_RAISE routine raises the exception
  52.  * using the usual raise procedure, and then exits directly at the top level
  53.  * of the PREDEF procedure, using longjmp.
  54.  */
  55.  
  56. jmp_buf raise_env;
  57.  
  58. static int string_offset(int *);
  59.  
  60. /* Procedure called by main interpreter to execute predefined operation. The
  61.  * operation code has been read from the code stream and is passed as the
  62.  * parameter. The remaining parameters are stacked as needed.
  63. */
  64.  
  65. void predef()                                /*;predef*/
  66. {
  67.     /* This procedure handles all predefined operations. It is passed a marker
  68.      * which determines the operation to be performed. The formal parameters of
  69.      * the original call have been evaluted onto CURSTACK, but must not be
  70.      * popped as then will be discarded by the code. In the case of generic
  71.      * procedures, the type template address is pushed on the parameters AND
  72.      *  MUST BE POPPED!
  73.      */
  74.  
  75.     /* First capture environment for use by PREDEF_RAISE */
  76.  
  77.     if (setjmp(raise_env))
  78.         return;
  79.  
  80.     /* Switch on the operation code */
  81.  
  82.     switch(operation) {
  83.  
  84.  
  85.         /* 14.2.1  FILE MANAGEMENT */
  86.  
  87.  
  88.         /* SEQUENTIAL_IO:                                     */
  89.         /* procedure CREATE(FILE  : in out FILE_TYPE;         */
  90.         /*                  MODE  : in FILE_MODE := OUT_FILE; */
  91.         /*                  NAME  : in STRING    := "";       */
  92.         /*                  FORM  : in STRING    := "");      */
  93.  
  94.     case P_SIO_CREATE:
  95.         {
  96.             open_seq_io('C');
  97.             break;
  98.         }
  99.  
  100.  
  101.         /* DIRECT_IO:                                          */
  102.         /* procedure CREATE(FILE : in out FILE_TYPE;           */
  103.         /*                  MODE : in FILE_MODE := INOUT_FILE; */
  104.         /*                  NAME : in STRING    := "";         */
  105.         /*                  FORM : in STRING    := "");        */
  106.  
  107.     case P_DIO_CREATE:
  108.         {
  109.             open_dir_io('C');
  110.             break;
  111.         }
  112.  
  113.  
  114.         /* TEXT_IO:                                           */
  115.         /* procedure CREATE(FILE : in out FILE_TYPE;          */
  116.         /*                  MODE : in FILE_MODE := OUT_FILE;  */
  117.         /*                  NAME : in STRING    := "";        */
  118.         /*                  FORM : in STRING    := "");       */
  119.  
  120.     case P_TIO_CREATE:
  121.         {
  122.             open_textio('C');
  123.             break;
  124.         }
  125.  
  126.  
  127.         /*  SEQUENTIAL_IO:                           */
  128.         /*  procedure OPEN(FILE : in out FILE_TYPE;  */
  129.         /*                 MODE : in FILE_MODE;      */
  130.         /*                 NAME : in STRING;         */
  131.         /*                 FORM : in STRING := "");  */
  132.  
  133.     case P_SIO_OPEN:
  134.         {
  135.             open_seq_io('O');
  136.             break;
  137.         }
  138.  
  139.  
  140.         /* DIRECT_IO:                                */
  141.         /* procedure OPEN(FILE : in out FILE_TYPE;   */
  142.         /*                MODE : in FILE_MODE;       */
  143.         /*                NAME : in STRING;          */
  144.         /*                FORM : in STRING := "");   */
  145.  
  146.     case P_DIO_OPEN:
  147.         {
  148.             open_dir_io('O');
  149.             break;
  150.         }
  151.  
  152.  
  153.         /* TEXT_IO:                                  */
  154.         /* procedure OPEN(FILE : in out FILE_TYPE;   */
  155.         /*                MODE : in FILE_MODE;       */
  156.         /*                NAME : in STRING;          */
  157.         /*                FORM : in STRING := "");   */
  158.  
  159.     case P_TIO_OPEN:
  160.         {
  161.             open_textio('O');
  162.             break;
  163.         }
  164.  
  165.  
  166.         /* procedure CLOSE(FILE : in out FILE_TYPE); */
  167.  
  168.     case P_SIO_CLOSE:
  169.     case P_DIO_CLOSE:
  170.     case P_TIO_CLOSE:
  171.         {
  172.             int    *file_ptr;
  173.  
  174.             file_ptr = get_argument_ptr(0);
  175.             filenum = *file_ptr;
  176.             check_file_open();
  177.  
  178.             *file_ptr = 0;
  179.  
  180.             if (operation == P_SIO_CLOSE || operation == P_DIO_CLOSE)
  181.                 close_file();
  182.             else /* operation == P_TIO_CLOSE */
  183.                 close_textio();
  184.             break;
  185.         }
  186.  
  187.         /*  procedure DELETE(FILE : in out FILE_TYPE); */
  188.  
  189.     case P_SIO_DELETE:
  190.     case P_DIO_DELETE:
  191.     case P_TIO_DELETE:
  192.         {
  193.             int    *file_ptr;
  194.  
  195.             file_ptr = get_argument_ptr(0);
  196.             filenum = *file_ptr;
  197.             check_file_open();
  198.  
  199.             strcpy(work_string, IOFNAME);
  200.  
  201.             if (operation == P_SIO_DELETE || P_DIO_DELETE)
  202.                 close_file();
  203.             else /* operation == P_TIO_DELETE */
  204.                 close_textio();
  205.             unlink(work_string);
  206.  
  207.             *file_ptr = 0;
  208.             break;
  209.         }
  210.  
  211.  
  212.         /*  SEQUENTIAL_IO:                                                 */
  213.         /*  procedure RESET(FILE : in out FILE_TYPE; MODE : in FILE_MODE); */
  214.         /*  procedure RESET(FILE : in out FILE_TYPE);                      */
  215.  
  216.     case P_SIO_RESET:
  217.     case P_SIO_RESET_MODE:
  218.         {
  219.             int    newmode;
  220.  
  221.             DISCARD_GENERIC_PARAMETER;
  222.             get_filenum();
  223.             check_file_open();
  224.  
  225.             if (operation == P_SIO_RESET_MODE) {
  226.                 newmode = get_argument_value(2);
  227.             }
  228.             else
  229.                 newmode = IOMODE;
  230.  
  231.             fclose(IOFDESC);
  232.  
  233.             if (newmode == SIO_IN_FILE) {
  234.                 IOFDESC = fopen_bin(IOFNAME, "r");
  235.                 check_opened_ok();
  236.             }
  237.             else {
  238.                 IOFDESC = fopen_bin(IOFNAME, "r+");
  239.                 check_opened_ok();
  240.             }
  241.             IOMODE = newmode;
  242.             break;
  243.         }
  244.  
  245.         /* DIRECT_IO:                                                       */
  246.         /* procedure RESET (FILE : in out FILE_TYPE;  MODE : in FILE_MODE); */
  247.         /* procedure RESET (FILE : in out FILE_TYPE);                       */
  248.  
  249.     case P_DIO_RESET:
  250.     case P_DIO_RESET_MODE:
  251.         {
  252.             int    newmode;
  253.  
  254.             DISCARD_GENERIC_PARAMETER;
  255.             get_filenum();
  256.  
  257.             check_file_open();
  258.  
  259.             if (operation == P_DIO_RESET_MODE)
  260.                 newmode = get_argument_value(2);
  261.             else
  262.                 newmode = IOMODE;
  263.  
  264.             fclose(IOFDESC);
  265.  
  266.             if (newmode == DIO_IN_FILE) {
  267.                 IOFDESC = fopen_bin(IOFNAME, "r");
  268.             }
  269.             else {
  270.                 IOFDESC = fopen_bin(IOFNAME, "r+");
  271.             }
  272.             check_opened_ok();
  273.  
  274.             IOMODE = newmode;
  275.             DPOS = 1;
  276.             break;
  277.         }
  278.  
  279.         /* TEXT_IO:                                                       */
  280.         /* procedure RESET(FILE : in out FILE_TYPE; MODE : in FILE_MODE); */
  281.         /* procedure RESET(FILE : in out FILE_TYPE);                      */
  282.  
  283.     case P_TIO_RESET:
  284.     case P_TIO_RESET_MODE:
  285.         {
  286.             int     newmode;
  287.  
  288.             get_filenum();
  289.             check_file_open();
  290.  
  291.             if (operation == P_TIO_RESET_MODE) {
  292.                 newmode = get_argument_value(2);
  293.  
  294.                 /* Raise MODE_ERROR on attempt to change the mode of the
  295.                  * current default input or output file. */
  296.  
  297.                 if ((filenum == current_in_file || filenum == current_out_file)
  298.                   && newmode != IOMODE) {
  299.                     predef_raise(MODE_ERROR, "Cannot change mode");
  300.                 }
  301.             }
  302.             else
  303.                 newmode = IOMODE;
  304.  
  305.             if (IOMODE == TIO_OUT_FILE) {
  306.  
  307.                 /* Simulate NEW_PAGE unless current page already terminated */
  308.  
  309.                 if (!PAGE_TERMINATED) {
  310.                     if (COL > 1 ||(COL == 1 && LINE == 1)) {
  311.                         put_line();
  312.                     }
  313.                     put_page();
  314.                 }
  315.             }
  316.  
  317.             fclose(IOFDESC);
  318.  
  319.             if (newmode == TIO_IN_FILE) {
  320.                 IOFDESC = fopen_txt(IOFNAME, "r");
  321.                 check_opened_ok();
  322.             }
  323.             else {
  324.                 IOFDESC = fopen_txt(IOFNAME, "r+");
  325.                 check_opened_ok();
  326.                 LINE_LENGTH = 0;
  327.                 PAGE_LENGTH = 0;
  328.             }
  329.  
  330.             IOMODE = newmode;
  331.             CHARS = 0;
  332.             COL = 1;
  333.             LINE = 1;
  334.             PAGE = 1;
  335.             break;
  336.         }
  337.  
  338.         /* function MODE(FILE : in FILE_TYPE) return FILE_MODE; */
  339.  
  340.     case P_SIO_MODE:
  341.     case P_DIO_MODE:
  342.     case P_TIO_MODE:
  343.         {
  344.             get_filenum();
  345.             check_file_open();
  346.             TOSM(2) = IOMODE;
  347.             break;
  348.         }
  349.  
  350.  
  351.         /* function NAME(FILE : in FILE_TYPE) return STRING; */
  352.  
  353.     case P_SIO_NAME:
  354.     case P_DIO_NAME:
  355.     case P_TIO_NAME:
  356.         {
  357.             get_filenum();
  358.             check_file_open();
  359.             return_string(IOFNAME, 2);
  360.             break;
  361.         }
  362.  
  363.  
  364.         /* function FORM(FILE : in FILE_TYPE) return STRING; */
  365.  
  366.     case P_SIO_FORM:
  367.     case P_DIO_FORM:
  368.     case P_TIO_FORM:
  369.         {
  370.             get_filenum();
  371.             check_file_open();
  372.             return_string(IOFORM, 2);
  373.             break;
  374.         }
  375.  
  376.  
  377.         /* function IS_OPEN(FILE : in FILE_TYPE) return BOOLEAN; */
  378.  
  379.     case P_SIO_IS_OPEN:
  380.     case P_DIO_IS_OPEN:
  381.     case P_TIO_IS_OPEN:
  382.         {
  383.             get_filenum();
  384.             TOSM(2) = (filenum != 0);
  385.             break;
  386.         }
  387.  
  388.  
  389.  
  390.         /* 14.2.2  SEQUENTIAL INPUT-OUTPUT */
  391.  
  392.  
  393.         /* procedure READ(FILE : in FILE_TYPE; ITEM : out ELEMENT_TYPE); */
  394.  
  395.     case P_SIO_READ:
  396.         {
  397.             int     *item_tt_ptr;
  398.             int     *item_ptr;
  399.             int     length, lread;
  400.             int     type;
  401.  
  402.             POP_PTR(item_tt_ptr);          /* pop generic type */
  403.  
  404.             /* If the type is an array, then we have an extra entry
  405.                  * on the stack, which is the descriptor for the actual
  406.                  * array value. In this case we want to use the length
  407.                  * from the actual value, rather than from the generic
  408.                  * template. In other cases, the length comes from the
  409.                  * generic template */
  410.  
  411.             type = TYPE(item_tt_ptr);
  412.             if (type == TT_C_ARRAY || type == TT_S_ARRAY ||
  413.                 type == TT_D_ARRAY) {
  414.                 item_tt_ptr = get_argument_ptr(2);
  415.                 item_ptr = get_argument_ptr(4);
  416.             }
  417.             else {
  418.                 item_ptr = get_argument_ptr(2);
  419.             }
  420.  
  421.             length = SIZE(item_tt_ptr);
  422.  
  423.             get_filenum();
  424.  
  425.             check_status(SIO_IN_FILE);
  426.  
  427.             lread = fread(item_ptr,sizeof(int),length,IOFDESC);
  428.             if (lread == 0)
  429.                 predef_raise(END_ERROR, "End of file");
  430.             else if (lread < length)
  431.                 predef_raise(DATA_ERROR, "Wrong length item at end of file");
  432.             break;
  433.         }
  434.  
  435.  
  436.         /* procedure WRITE(FILE : in FILE_TYPE; ITEM : in ELEMENT_TYPE); */
  437.  
  438.     case P_SIO_WRITE:
  439.         {
  440.             int     *item_tt_ptr;
  441.             int     *item_ptr;
  442.             int     length, lwrit;
  443.             int     type;
  444.  
  445.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  446.  
  447.             /* If the type is an array, then we have an extra entry
  448.                  * on the stack, which is the descriptor for the actual
  449.                  * array value. In this case we want to use the length
  450.                  * from the actual value, rather than from the generic
  451.                  * template. In other cases, the length comes from the
  452.                  * generic template */
  453.  
  454.             type = TYPE(item_tt_ptr);
  455.             if (type == TT_C_ARRAY || type == TT_S_ARRAY ||
  456.                 type == TT_D_ARRAY) {
  457.                 item_tt_ptr = get_argument_ptr(2);
  458.                 item_ptr = get_argument_ptr(4);
  459.             }
  460.             else {
  461.                 item_ptr = get_argument_ptr(2);
  462.             }
  463.  
  464.             length = SIZE(item_tt_ptr);
  465.  
  466.             get_filenum();
  467.  
  468.             check_status(SIO_OUT_FILE);
  469.  
  470.             lwrit = fwrite(item_ptr,sizeof(int),length,IOFDESC);
  471.             if (lwrit < length) {
  472.                 predef_raise(END_ERROR, "File full");
  473.             }
  474.             break;
  475.         }
  476.  
  477.  
  478.         /* function END_OF_FILE(FILE : in FILE_TYPE) return BOOLEAN; */
  479.  
  480.     case P_SIO_END_OF_FILE:
  481.         {
  482.             long    curpos, eofpos;
  483.  
  484.             get_filenum();
  485.             check_status(SIO_IN_FILE);
  486.  
  487.             fseek(IOFDESC, 0L, 1);
  488.             curpos = ftell(IOFDESC);
  489.             fseek(IOFDESC, 0L, 2);
  490.             eofpos = ftell(IOFDESC);
  491.             fseek(IOFDESC, curpos, 0);
  492.             TOSM(2) = (curpos == eofpos);
  493.             break;
  494.         }
  495.  
  496.  
  497.         /* 14.2.4  DIRECT INPUT-OUTPUT */
  498.  
  499.  
  500.         /* procedure READ(FILE : in FILE_TYPE; ITEM : out ELEMENT_TYPE);   */
  501.         /* procedure READ(FILE : in FILE_TYPE; ITEM : out ELEMENT_TYPE;    */
  502.         /*                                     FROM : in  POSITIVE_COUNT); */
  503.  
  504.     case P_DIO_READ:
  505.     case P_DIO_READ_FROM:
  506.         {
  507.             int     *item_tt_ptr;
  508.             int     *item_ptr;
  509.             int     type_offset;
  510.             int     from;
  511.             long    newpos;
  512.             int     type;
  513.  
  514.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  515.  
  516.             /* If the type is an array, then we have an extra entry
  517.                  * on the stack, which is the descriptor for the actual
  518.                  * array value. */
  519.  
  520.             type = TYPE(item_tt_ptr);
  521.             if (type == TT_C_ARRAY || type == TT_S_ARRAY || type == TT_D_ARRAY)
  522.             {
  523.                 item_tt_ptr = get_argument_ptr(2);
  524.                 type_offset = 2;
  525.             }
  526.             else type_offset = 0;
  527.  
  528.             item_ptr = get_argument_ptr(2 + type_offset);
  529.  
  530.             get_filenum();
  531.             check_file_open();
  532.  
  533.             if (operation == P_DIO_READ_FROM) {
  534.                 if (type == TT_RECORD) {
  535.                     from = get_argument_value(4);
  536.                 }
  537.                 else {
  538.                     from = get_argument_value(6);
  539.                 }
  540.             }
  541.             else from = DPOS;
  542.  
  543.             if (IOMODE == DIO_OUT_FILE) {
  544.                 predef_raise(MODE_ERROR, "Direct read from OUT file");
  545.             }
  546.  
  547.             if (from > DSIZE) {
  548.                 predef_raise(END_ERROR, "Direct read past end of file");
  549.             }
  550.  
  551.             newpos = (from - 1) * DLENGTH;
  552.             fseek(IOFDESC, newpos, 0);
  553.             fread(item_ptr, 1, DLENGTH, IOFDESC);
  554.  
  555.             DPOS = from + 1;
  556.             break;
  557.         }
  558.  
  559.  
  560.         /* procedure WRITE(FILE : in FILE_TYPE; ITEM : in ELEMENT_TYPE); */
  561.         /* procedure WRITE(FILE : in FILE_TYPE; ITEM : in ELEMENT_TYPE;  */
  562.         /*                                        TO : in POSITIVE_COUNT); */
  563.  
  564.     case P_DIO_WRITE:
  565.     case P_DIO_WRITE_TO:
  566.         {
  567.             int     *item_tt_ptr;
  568.             int     *item_ptr;
  569.             int     type_offset;
  570.             int     to;
  571.             long    newpos;
  572.             int     type;
  573.  
  574.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  575.  
  576.             /* If the type is an array, then we have an extra entry
  577.                  * on the stack, which is the descriptor for the actual
  578.                  * array value. */
  579.  
  580.             type = TYPE(item_tt_ptr);
  581.             if (type == TT_C_ARRAY || type == TT_S_ARRAY || type == TT_D_ARRAY)
  582.             {
  583.                 item_tt_ptr = get_argument_ptr(2);
  584.                 type_offset = 2;
  585.             }
  586.             else type_offset = 0;
  587.  
  588.             item_ptr = get_argument_ptr(2 + type_offset);
  589.             get_filenum();
  590.             check_file_open();
  591.  
  592.             if (operation == P_DIO_WRITE_TO) {
  593.                 to = get_argument_value(4 + type_offset);
  594.             }
  595.             else to = DPOS;
  596.  
  597.             if (IOMODE == DIO_IN_FILE) {
  598.                 predef_raise(MODE_ERROR, "Direct write to an IN file");
  599.             }
  600.  
  601.             newpos = (to - 1) * DLENGTH;
  602.             fseek(IOFDESC, newpos, 0);
  603.             fwrite(item_ptr, 1, DLENGTH, IOFDESC);
  604.  
  605.             DPOS = to + 1;
  606.             if (to > DSIZE) DSIZE = to;
  607.             break;
  608.         }
  609.  
  610.  
  611.         /* procedure SET_INDEX(FILE : in FILE_TYPE; TO : in POSITIVE_COUNT); */
  612.  
  613.     case P_DIO_SET_INDEX:
  614.         {
  615.             get_filenum();
  616.             check_file_open();
  617.  
  618.             DPOS = get_argument_value(2);
  619.             break;
  620.         }
  621.  
  622.  
  623.         /* function INDEX(FILE : in FILE_TYPE) return POSITIVE_COUNT; */
  624.  
  625.     case P_DIO_INDEX:
  626.         {
  627.             get_filenum();
  628.             check_file_open();
  629.  
  630.             TOSM(2) = DPOS;
  631.             break;
  632.         }
  633.  
  634.  
  635.         /* function SIZE(FILE : in FILE_TYPE) return COUNT; */
  636.  
  637.     case P_DIO_SIZE:
  638.         {
  639.             get_filenum();
  640.             check_file_open();
  641.  
  642.             TOSM(2) = DSIZE;
  643.             break;
  644.         }
  645.  
  646.  
  647.         /* function END_OF_FILE(FILE : in FILE_TYPE) return BOOLEAN; */
  648.  
  649.     case P_DIO_END_OF_FILE:
  650.         {
  651.             get_filenum();
  652.             check_file_open();
  653.  
  654.             if (IOMODE == DIO_OUT_FILE) {
  655.                 predef_raise(MODE_ERROR, "Bad mode in direct END_OF_FILE");
  656.             }
  657.  
  658.             TOSM(2) = (DPOS > DSIZE);
  659.             break;
  660.         }
  661.  
  662.  
  663.  
  664.         /* 14.3.2  DEFAULT INPUT AND OUTPUT FILES */
  665.  
  666.  
  667.         /* procedure SET_INPUT(FILE : in FILE_TYPE); */
  668.  
  669.     case P_SET_INPUT:
  670.         {
  671.             get_filenum();
  672.             check_status(TIO_IN_FILE);
  673.  
  674.             current_in_file = filenum;
  675.             /* Save a copy of the current default input file number 
  676.              * which can be checked after the default file is closed.
  677.              */
  678.             current_in_file_saved = filenum;
  679.             break;
  680.         }
  681.  
  682.  
  683.         /* procedure SET_OUTPUT(FILE : in FILE_TYPE); */
  684.  
  685.     case P_SET_OUTPUT:
  686.         {
  687.             get_filenum();
  688.             check_status(TIO_OUT_FILE);
  689.             current_out_file = filenum;
  690.             /* Save a copy of the current default output file number 
  691.              * which can be checked after the default file is closed.
  692.              */
  693.             current_out_file_saved = filenum;
  694.             break;
  695.         }
  696.  
  697.  
  698.         /* function STANDARD_INPUT return FILE_TYPE; */
  699.  
  700.     case P_STANDARD_INPUT:
  701.         {
  702.             int     bse, off, *ptr;
  703.             create(1, &bse, &off, &ptr);
  704.             *ptr = standard_in_file;
  705.             TOSM(1) = bse;
  706.             TOS = off;
  707.             break;
  708.         }
  709.  
  710.  
  711.         /* function STANDARD_OUTPUT return FILE_TYPE; */
  712.  
  713.     case P_STANDARD_OUTPUT:
  714.         {
  715.             int     bse, off, *ptr;
  716.             create(1, &bse, &off, &ptr);
  717.             *ptr = standard_out_file;
  718.             TOSM(1) = bse;
  719.             TOS = off;
  720.             break;
  721.         }
  722.  
  723.  
  724.         /* function CURRENT_INPUT return FILE_TYPE; */
  725.  
  726.     case P_CURRENT_INPUT:
  727.         {
  728.             int     bse, off, *ptr;
  729.             create(1, &bse, &off, &ptr);
  730.             *ptr = current_in_file;
  731.             TOSM(1) = bse;
  732.             TOS = off;
  733.             break;
  734.         }
  735.  
  736.  
  737.         /* function CURRENT_OUTPUT return FILE_TYPE; */
  738.  
  739.     case P_CURRENT_OUTPUT:
  740.         {
  741.             int     bse, off, *ptr;
  742.             create(1, &bse, &off, &ptr);
  743.             *ptr = current_out_file;
  744.             TOSM(1) = bse;
  745.             TOS = off;
  746.             break;
  747.         }
  748.  
  749.  
  750.         /* 14.3.3  SPECIFICATION OF LINE AND PAGE LENGTHS */
  751.  
  752.  
  753.         /* procedure SET_LINE_LENGTH(FILE : in FILE_TYPE; TO : in COUNT); */
  754.         /* procedure SET_LINE_LENGTH(TO : in COUNT);                      */
  755.  
  756.     case P_SET_LINE_LENGTH:
  757.     case P_SET_LINE_LENGTH_FILE:
  758.         {
  759.             get_file_argument_or_default();
  760.             check_status(TIO_OUT_FILE);
  761.  
  762.             LINE_LENGTH = get_argument_value(0 + file_offset);
  763.             break;
  764.         }
  765.  
  766.  
  767.         /* procedure SET_PAGE_LENGTH(FILE : in FILE_TYPE;   TO : in COUNT); */
  768.         /* procedure SET_PAGE_LENGTH(TO : in COUNT);                        */
  769.  
  770.     case P_SET_PAGE_LENGTH:
  771.     case P_SET_PAGE_LENGTH_FILE:
  772.         {
  773.             get_file_argument_or_default();
  774.             check_status(TIO_OUT_FILE);
  775.  
  776.             PAGE_LENGTH = get_argument_value(0 + file_offset);
  777.             break;
  778.         }
  779.  
  780.  
  781.         /* function LINE_LENGTH(FILE : in FILE_TYPE) return COUNT; */
  782.         /* function LINE_LENGTH return COUNT;                      */
  783.  
  784.     case P_LINE_LENGTH:
  785.     case P_LINE_LENGTH_FILE:
  786.         {
  787.             get_file_argument_or_default();
  788.             check_status(TIO_OUT_FILE);
  789.  
  790.             TOSM(0 + file_offset) = LINE_LENGTH;
  791.             break;
  792.         }
  793.  
  794.  
  795.         /* function PAGE_LENGTH(FILE : in FILE_TYPE) return COUNT; */
  796.         /* function PAGE_LENGTH return COUNT;                      */
  797.  
  798.     case P_PAGE_LENGTH:
  799.     case P_PAGE_LENGTH_FILE:
  800.         {
  801.             get_file_argument_or_default();
  802.             check_status(TIO_OUT_FILE);
  803.  
  804.             TOSM(0 + file_offset) = PAGE_LENGTH;
  805.             break;
  806.         }
  807.  
  808.  
  809.         /* 14.3.4  OPERATIONS ON COLUMNS, LINES, AND PAGES */
  810.  
  811.  
  812.         /* procedure NEW_LINE(FILE : in FILE_TYPE;                */
  813.         /*                     SPACING : in POSITIVE_COUNT := 1); */
  814.         /* procedure NEW_LINE(SPACING : in POSITIVE_COUNT := 1);  */
  815.  
  816.     case P_NEW_LINE_FILE:
  817.     case P_NEW_LINE:
  818.         {
  819.             int     spacing, i;
  820.  
  821.             get_file_argument_or_default();
  822.             check_status(TIO_OUT_FILE);
  823.  
  824.             spacing = get_argument_value(0 + file_offset);
  825.  
  826.             for (i = 1; i <= spacing; i++) {
  827.                 put_line();
  828.             }
  829.             break;
  830.         }
  831.  
  832.  
  833.         /* procedure SKIP_LINE(FILE : in FILE_TYPE;               */
  834.         /*                     SPACING : in POSITIVE_COUNT := 1); */
  835.         /* procedure SKIP_LINE(SPACING : in POSITIVE_COUNT := 1); */
  836.  
  837.     case P_SKIP_LINE_FILE:
  838.     case P_SKIP_LINE:
  839.         {
  840.             int     spacing;
  841.             int     i;
  842.  
  843.             get_file_argument_or_default();
  844.             check_status(TIO_IN_FILE);
  845.  
  846.             spacing = get_argument_value(0 + file_offset);
  847.  
  848.             for (i = 1; i <= spacing; i++) {
  849.                 skip_line();
  850.             }
  851.             break;
  852.         }
  853.  
  854.  
  855.         /* function END_OF_LINE(FILE : in FILE_TYPE) return BOOLEAN; */
  856.         /* function END_OF_LINE return BOOLEAN;                      */
  857.  
  858.     case P_END_OF_LINE_FILE:
  859.     case P_END_OF_LINE:
  860.         {
  861.             get_file_argument_or_default();
  862.             check_status(TIO_IN_FILE);
  863.  
  864.             load_look_ahead(FALSE);
  865.             TOSM(0 + file_offset) = (CHARS == 0 || CHAR1 == LINE_FEED);
  866.             break;
  867.         }
  868.  
  869.  
  870.         /* procedure NEW_PAGE(FILE : in FILE_TYPE); */
  871.         /* procedure NEW_PAGE;                      */
  872.  
  873.     case P_NEW_PAGE_FILE:
  874.     case P_NEW_PAGE:
  875.         {
  876.             get_file_argument_or_default();
  877.             check_status(TIO_OUT_FILE);
  878.  
  879.             if (COL > 1 ||(COL == 1 && LINE == 1)) {
  880.                 put_line();
  881.             }
  882.             put_page();
  883.             break;
  884.         }
  885.  
  886.  
  887.         /* procedure SKIP_PAGE(FILE : in FILE_TYPE); */
  888.         /* procedure SKIP_PAGE;                      */
  889.  
  890.     case P_SKIP_PAGE_FILE:
  891.     case P_SKIP_PAGE:
  892.         {
  893.             get_file_argument_or_default();
  894.             check_status(TIO_IN_FILE);
  895.  
  896.             while(get_char() != PAGE_MARK);
  897.             break;
  898.         }
  899.  
  900.  
  901.         /* function END_OF_PAGE(FILE : in FILE_TYPE) return BOOLEAN; */
  902.         /* function END_OF_PAGE return BOOLEAN;                      */
  903.  
  904.     case P_END_OF_PAGE_FILE:
  905.     case P_END_OF_PAGE:
  906.         {
  907.            int     result;
  908.  
  909.            get_file_argument_or_default();
  910.            check_status(TIO_IN_FILE);
  911.  
  912.            if (isatty(fileno(IOFDESC))) {
  913.               result = FALSE;
  914.            }
  915.             else {
  916.               load_look_ahead(FALSE);
  917.               if (CHARS > 1) 
  918.                   result = (CHAR1 == LINE_FEED && CHAR2 == PAGE_MARK);
  919.                else if (CHARS == 1)
  920.                   result = (CHAR1 == LINE_FEED);
  921.                else    /* CHARS == 0) */
  922.                   result = TRUE;
  923.            }
  924.            TOSM(0 + file_offset) = result;
  925.            break;
  926.         }
  927.  
  928.  
  929.         /* function END_OF_FILE(FILE : in FILE_TYPE) return BOOLEAN; */
  930.         /* function END_OF_FILE return BOOLEAN;                      */
  931.  
  932.     case P_TIO_END_OF_FILE:
  933.     case P_TIO_END_OF_FILE_FILE:
  934.         {
  935.            int     result;
  936.  
  937.            get_file_argument_or_default();
  938.            check_status(TIO_IN_FILE);
  939.  
  940.            load_look_ahead(TRUE);
  941.            if (isatty(fileno(IOFDESC))) {
  942.             if (CHARS == 2)
  943.                result = FALSE;
  944.             else if (CHARS == 1)
  945.                result = (CHAR1 == LINE_FEED);
  946.             else if (CHARS == 0)
  947.                result = TRUE;
  948.            }
  949.            else {
  950.             if (CHARS == 2)
  951.                result = (CHAR1 == LINE_FEED && CHAR2 == PAGE_MARK);
  952.             else if (CHARS == 1)
  953.                result = (CHAR1 == LINE_FEED);
  954.             else if (CHARS == 0)
  955.                result = TRUE;
  956.             else         /* CHARS = 3 */
  957.                result = FALSE;
  958.                    }
  959.             TOSM(0 + file_offset) = result;
  960.             break;
  961.         }
  962.  
  963.  
  964.         /* procedure SET_COL(FILE : in FILE_TYPE; TO : in POSITIVE_COUNT); */
  965.         /* procedure SET_COL(TO : in POSITIVE_COUNT);                      */
  966.  
  967.     case P_SET_COL:
  968.     case P_SET_COL_FILE:
  969.         {
  970.             int     to_val;
  971.  
  972.             get_file_argument_or_default();
  973.             to_val = get_argument_value(0 + file_offset);
  974.             check_file_open();
  975.  
  976.             /* SET_COL for file of mode OUT_FILE */
  977.  
  978.             if (IOMODE == TIO_OUT_FILE) {
  979.                 if (BOUNDED_LINE_LENGTH && to_val > LINE_LENGTH)
  980.                     predef_raise(LAYOUT_ERROR, "SET_COL past end of line");
  981.  
  982.                 if (to_val > COL) {
  983.                     put_blanks(to_val - COL);
  984.                     COL = to_val;
  985.                 }
  986.                 else if (to_val < COL) {
  987.                     put_line();
  988.                     put_blanks(to_val - 1);
  989.                     COL = to_val;
  990.                 }
  991.             }
  992.  
  993.             /* SET_COL for file of mode IN_FILE */
  994.  
  995.             else {
  996.                 load_look_ahead(FALSE);
  997.                 while(COL != to_val || CHAR1 == LINE_FEED || CHAR1 == PAGE_MARK)
  998.                     get_char();
  999.             }
  1000.  
  1001.             break;
  1002.         }
  1003.  
  1004.  
  1005.         /* procedure SET_LINE(FILE : in FILE_TYPE;  TO : in POSITIVE_COUNT); */
  1006.         /* procedure SET_LINE(TO   : in POSITIVE_COUNT);                     */
  1007.  
  1008.     case P_SET_LINE:
  1009.     case P_SET_LINE_FILE:
  1010.         {
  1011.             int     to_val;
  1012.             int     i;
  1013.  
  1014.             get_file_argument_or_default();
  1015.             to_val = get_argument_value(0 + file_offset);
  1016.             check_file_open();
  1017.  
  1018.             /* SET_LINE for file of mode OUT_FILE */
  1019.  
  1020.             if (IOMODE == TIO_OUT_FILE) {
  1021.                 if (BOUNDED_PAGE_LENGTH && to_val > PAGE_LENGTH) {
  1022.                     predef_raise(LAYOUT_ERROR, "SET_LINE > PAGE_LENGTH");
  1023.                 }
  1024.  
  1025.                 if (to_val > LINE) {
  1026.                     i = to_val - LINE;
  1027.                     while(i--)
  1028.                         put_line();
  1029.                 }
  1030.                 else if (to_val < LINE) {
  1031.                     if (COL > 1 ||(COL == 1 && LINE == 1))
  1032.                         put_line();
  1033.                     put_page();
  1034.                     i = to_val - 1;
  1035.                     while(i--)
  1036.                         put_line();
  1037.                 }
  1038.             }
  1039.  
  1040.             /* SET_LINE for file of mode IN_FILE */
  1041.  
  1042.             else {
  1043.                 load_look_ahead(FALSE);
  1044.                 while(LINE != to_val || CHAR1 == PAGE_MARK) {
  1045.                     get_char();
  1046.                 }
  1047.             }
  1048.             break;
  1049.         }
  1050.  
  1051.  
  1052.         /* function COL(FILE : FILE_TYPE)  return POSITIVE_COUNT; */
  1053.         /* function COL return POSITIVE_COUNT;                    */
  1054.  
  1055.     case P_COL:
  1056.     case P_COL_FILE:
  1057.         {
  1058.             get_file_argument_or_default();
  1059.             check_file_open();
  1060.  
  1061.             if (COL > COUNT_LAST) {
  1062.                 predef_raise(LAYOUT_ERROR, "COL > COUNT'LAST");
  1063.             }
  1064.  
  1065.             TOSM(0 + file_offset) = COL;
  1066.             break;
  1067.         }
  1068.  
  1069.  
  1070.         /* function LINE(FILE : FILE_TYPE) return POSITIVE_COUNT; */
  1071.         /* function LINE return POSITIVE_COUNT;                   */
  1072.  
  1073.     case P_LINE:
  1074.     case P_LINE_FILE:
  1075.         {
  1076.             get_file_argument_or_default();
  1077.             check_file_open();
  1078.  
  1079.             if (LINE < 0) {
  1080.                 predef_raise(LAYOUT_ERROR, "LINE > COUNT'LAST");
  1081.             }
  1082.  
  1083.             TOSM(0 + file_offset) = LINE;
  1084.             break;
  1085.         }
  1086.  
  1087.  
  1088.         /* function PAGE(FILE : FILE_TYPE) return POSITIVE_COUNT; */
  1089.         /* function PAGE return POSITIVE_COUNT;                   */
  1090.  
  1091.     case P_PAGE:
  1092.     case P_PAGE_FILE:
  1093.         {
  1094.             get_file_argument_or_default();
  1095.             check_file_open();
  1096.  
  1097.             if (PAGE > COUNT_LAST) {
  1098.                 predef_raise(LAYOUT_ERROR, "PAGE > COUNT'LAST");
  1099.             }
  1100.  
  1101.             TOSM(0 + file_offset) = PAGE;
  1102.             break;
  1103.         }
  1104.  
  1105.  
  1106.  
  1107.         /* 14.3.6  INPUT-OUTPUT OF CHARACTERS AND STRINGS */
  1108.  
  1109.  
  1110.         /* procedure GET(FILE : in FILE_TYPE; ITEM : out CHARACTER); */
  1111.         /* procedure GET(ITEM : out CHARACTER);                      */
  1112.  
  1113.     case P_GET_CHAR_FILE_ITEM:
  1114.     case P_GET_CHAR_ITEM:
  1115.         {
  1116.             int     *item_ptr;
  1117.             int     chr;
  1118.  
  1119.             get_file_argument_or_default();
  1120.             check_status(TIO_IN_FILE);
  1121.  
  1122.             item_ptr = get_argument_ptr(0 + file_offset);
  1123.  
  1124.             for (;;) {
  1125.                 chr = get_char();
  1126.                 if (chr != PAGE_MARK && chr != LINE_FEED)
  1127.                     break;
  1128.             }
  1129.             *item_ptr = chr;
  1130.             break;
  1131.         }
  1132.  
  1133.  
  1134.         /* procedure PUT(FILE : in FILE_TYPE; ITEM : in CHARACTER); */
  1135.         /* procedure PUT(ITEM : in CHARACTER);                      */
  1136.  
  1137.     case P_PUT_CHAR_FILE_ITEM:
  1138.     case P_PUT_CHAR_ITEM:
  1139.         {
  1140.             get_file_argument_or_default();
  1141.             check_status(TIO_OUT_FILE);
  1142.  
  1143.             put_char(get_argument_value(0 + file_offset));
  1144.             break;
  1145.         }
  1146.  
  1147.         /* procedure GET(FILE : in FILE_TYPE; ITEM : out STRING); */
  1148.         /* procedure GET(ITEM : out STRING);                      */
  1149.  
  1150.     case P_GET_STRING_FILE_ITEM:
  1151.     case P_GET_STRING_ITEM:
  1152.         {
  1153.             int    *item_tt_ptr;
  1154.             int     *item_ptr;
  1155.             int     string_size;
  1156.             char    c;
  1157.  
  1158.             get_file_argument_or_default();
  1159.             check_status(TIO_IN_FILE);
  1160.             item_tt_ptr = get_argument_ptr(0 + file_offset);
  1161.             item_ptr    = get_argument_ptr(2 + file_offset);
  1162.  
  1163.             string_size = SIZE(item_tt_ptr);
  1164.  
  1165.             while(string_size) {
  1166.                 c = get_char();
  1167.                 if (c != PAGE_MARK && c != LINE_FEED) {
  1168.                     *item_ptr++ = c;
  1169.                     string_size--;
  1170.                 }
  1171.             }
  1172.             break;
  1173.         }
  1174.  
  1175.  
  1176.         /* procedure PUT(FILE : in FILE_TYPE; ITEM : in STRING); */
  1177.         /* procedure PUT(ITEM : in STRING);                      */
  1178.  
  1179.     case P_PUT_STRING_FILE_ITEM:
  1180.     case P_PUT_STRING_ITEM:
  1181.         {
  1182.             get_file_argument_or_default();
  1183.             check_status(TIO_OUT_FILE);
  1184.             get_string_value(0 + file_offset);
  1185.  
  1186.             put_string(work_string);
  1187.             break;
  1188.         }
  1189.  
  1190.  
  1191.         /*  procedure GET_LINE(FILE : in FILE_TYPE;  ITEM : out STRING;   */
  1192.         /*                                           LAST : out INTEGER); */
  1193.         /*  procedure GET_LINE(ITEM : out STRING; LAST : out INTEGER);    */
  1194.  
  1195.     case P_GET_LINE_FILE:
  1196.     case P_GET_LINE:
  1197.         {
  1198.             int     *item_tt_ptr;
  1199.             int     *item_ptr;
  1200.             int     *last_ptr;
  1201.             int     string_size;
  1202.             int     nstore;
  1203.             char    c;
  1204.  
  1205.             get_file_argument_or_default();
  1206.             check_status(TIO_IN_FILE);
  1207.  
  1208.             item_tt_ptr = get_argument_ptr(0 + file_offset);
  1209.             item_ptr    = get_argument_ptr(2 + file_offset);
  1210.             last_ptr    = get_argument_ptr(4 + file_offset);
  1211.  
  1212.             string_size = SIZE(item_tt_ptr);
  1213.             if (string_size < 0) string_size = 0;
  1214.  
  1215.             nstore = 0;
  1216.             for (;;) {
  1217.                 load_look_ahead(FALSE);
  1218.                 if (nstore == string_size) break;
  1219.                 if (CHAR1 == LINE_FEED) {
  1220.                     skip_line();
  1221.                     break;
  1222.                 }
  1223.                 c = get_char();
  1224.                 *item_ptr++ = c;
  1225.                 nstore ++;
  1226.             }
  1227.  
  1228.             /* set LAST value */
  1229.  
  1230.             *last_ptr = nstore + string_offset(item_tt_ptr) - 1;
  1231.             break;
  1232.         }
  1233.  
  1234.  
  1235.         /* procedure PUT_LINE(FILE : in FILE_TYPE; ITEM : in STRING); */
  1236.         /* procedure PUT_LINE(ITEM : in STRING);                      */
  1237.  
  1238.     case P_PUT_LINE_FILE:
  1239.     case P_PUT_LINE:
  1240.         {
  1241.             get_file_argument_or_default();
  1242.             check_status(TIO_OUT_FILE);
  1243.  
  1244.             get_string_value(0 + file_offset);
  1245.             put_string(work_string);
  1246.             put_line();
  1247.             break;
  1248.         }
  1249.  
  1250.  
  1251.         /* 14.3.7  INPUT-OUTPUT FOR INTEGER TYPES */
  1252.  
  1253.  
  1254.         /* type NUM is range <>;                                        */
  1255.         /* procedure GET(FILE : in FILE_TYPE;  ITEM : out NUM;         */
  1256.         /*                                      WIDTH : in FIELD := 0); */
  1257.         /* procedure GET(ITEM : out NUM;  WIDTH : in FIELD := 0);      */
  1258.  
  1259.     case P_GET_INTEGER_FILE_ITEM:
  1260.     case P_GET_INTEGER_ITEM:
  1261.         {
  1262.             int     *item_tt_ptr;
  1263.             int     *item_ptr;
  1264.             int     width;
  1265.  
  1266.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1267.  
  1268.             get_file_argument_or_default();
  1269.             check_status(TIO_IN_FILE);
  1270.  
  1271.             item_ptr = get_argument_ptr(0 + file_offset);
  1272.             width = get_argument_value(4 + file_offset);
  1273.  
  1274.             *item_ptr = scan_integer(item_tt_ptr, width);
  1275.             break;
  1276.         }
  1277.  
  1278.  
  1279.         /* procedure PUT(FILE  : in FILE_TYPE;                     */
  1280.         /*                ITEM  : in NUM;                          */
  1281.         /*                WIDTH : in FIELD       := DEFAULT_WIDTH; */
  1282.         /*                BASE  : in NUMBER_BASE := DEFAULT_BASE); */
  1283.  
  1284.         /* procedure PUT(ITEM  : in NUM;                           */
  1285.         /*               WIDTH : in FIELD       := DEFAULT_WIDTH;  */
  1286.         /*               BASE  : in NUMBER_BASE := DEFAULT_BASE);  */
  1287.  
  1288.     case P_PUT_INTEGER_FILE_ITEM:
  1289.     case P_PUT_INTEGER_ITEM:
  1290.         {
  1291.             int     item, width, a_base;
  1292.  
  1293.             DISCARD_GENERIC_PARAMETER;
  1294.  
  1295.             get_file_argument_or_default();
  1296.             check_status(TIO_OUT_FILE);
  1297.  
  1298.             item = get_argument_value(0 + file_offset);
  1299.             width = get_argument_value(2 + file_offset);
  1300.             a_base = get_argument_value(4 + file_offset);
  1301.  
  1302.             image_integer(item, a_base);
  1303.             put_buffer(work_string, width, 'L');
  1304.             break;
  1305.         }
  1306.  
  1307.  
  1308.         /* procedure
  1309.          *   GET(FROM : in STRING; ITEM : out NUM; LAST : out POSITIVE);
  1310.          */
  1311.  
  1312.     case P_GET_INTEGER_STRING:
  1313.         {
  1314.             int     *item_tt_ptr;
  1315.             int     *from_tt_ptr;
  1316.             int     *item_ptr;
  1317.             int     *last_ptr;
  1318.             int     last;
  1319.  
  1320.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1321.  
  1322.             get_string_value(0);
  1323.             from_tt_ptr = get_argument_ptr(0);
  1324.             item_ptr    = get_argument_ptr(4);
  1325.             last_ptr    = get_argument_ptr(8);
  1326.  
  1327.             *item_ptr = scan_integer_string(item_tt_ptr, &last);
  1328.  
  1329.             last += string_offset(from_tt_ptr) ;
  1330.             *last_ptr = last;
  1331.             break;
  1332.         }
  1333.  
  1334.  
  1335.         /* procedure PUT(TO   : out STRING;                       */
  1336.         /*               ITEM : in  NUM;                          */
  1337.         /*               BASE : in  NUMBER_BASE := DEFAULT_BASE); */
  1338.  
  1339.     case P_PUT_INTEGER_STRING:
  1340.         {
  1341.             int     *to_tt_ptr;
  1342.             int     *to_ptr;
  1343.             int     item, a_base;
  1344.             int     string_size, slength;
  1345.             char    *c;
  1346.  
  1347.             DISCARD_GENERIC_PARAMETER;
  1348.             to_tt_ptr = get_argument_ptr(0);
  1349.             to_ptr    = get_argument_ptr(2);
  1350.             item      = get_argument_value(4);
  1351.             a_base    = get_argument_value(6);
  1352.  
  1353.             string_size = SIZE(to_tt_ptr);
  1354.  
  1355.             image_integer(item, a_base);
  1356.             slength = strlen(work_string);
  1357.  
  1358.             if (slength > string_size) {
  1359.                 predef_raise(LAYOUT_ERROR, "String too long");
  1360.             }
  1361.  
  1362.             c = work_string;
  1363.             while(string_size-- > slength) *to_ptr++ = ' ';
  1364.             while(slength--) *to_ptr++ = *c++;
  1365.             break;
  1366.         }
  1367.  
  1368.  
  1369.         /* 14.3.8  INPUT-OUTPUT FOR REAL TYPES */
  1370.  
  1371.  
  1372.         /* type NUM is digits <>;                                      */
  1373.         /* procedure GET(FILE : in FILE_TYPE;  ITEM  : out NUM;        */
  1374.         /*                                     WIDTH : in FIELD := 0); */
  1375.         /* procedure GET(ITEM : out NUM;  WIDTH : in FIELD := 0);      */
  1376.  
  1377.     case P_GET_FLOAT_FILE_ITEM:
  1378.     case P_GET_FLOAT_ITEM:
  1379.         {
  1380.             int     *item_tt_ptr;
  1381.             int     *item_ptr;
  1382.             int     width;
  1383.             float   fval;
  1384.  
  1385.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1386.  
  1387.             get_file_argument_or_default();
  1388.             check_status(TIO_IN_FILE);
  1389.  
  1390.             item_ptr = get_argument_ptr(0 + file_offset);
  1391.             width  = get_argument_value(4 + file_offset);
  1392.  
  1393.             fval = scan_float(item_tt_ptr, width);
  1394.  
  1395.             *((float *)(item_ptr)) = fval;
  1396.             break;
  1397.         }
  1398.  
  1399.         /* procedure PUT(FILE     : in FILE_TYPE;             */
  1400.         /*               ITEM     : in NUM;                   */
  1401.         /*               FORE     : in FIELD := DEFAULT_FORE; */
  1402.         /*               AFT      : in FIELD := DEFAULT_AFT;  */
  1403.         /*               EXP      : in FIELD := DEFAULT_EXP); */
  1404.  
  1405.         /* procedure PUT(ITEM     : in NUM;                   */
  1406.         /*               FORE     : in FIELD := DEFAULT_FORE; */
  1407.         /*               AFT      : in FIELD := DEFAULT_AFT;  */
  1408.         /*               EXP      : in FIELD := DEFAULT_EXP); */
  1409.  
  1410.     case P_PUT_FLOAT_FILE_ITEM:
  1411.     case P_PUT_FLOAT_ITEM:
  1412.         {
  1413.             int     fore, aft, expnt;
  1414.             float   fitem;
  1415.  
  1416.             DISCARD_GENERIC_PARAMETER;
  1417.  
  1418.             get_file_argument_or_default();
  1419.             check_status(TIO_OUT_FILE);
  1420.  
  1421.             fitem = get_float_argument_value(0 + file_offset);
  1422.             fore  = get_argument_value(2 + file_offset);
  1423.             aft   = get_argument_value(4 + file_offset);
  1424.             expnt = get_argument_value(6 + file_offset);
  1425.  
  1426.             image_float(fitem, fore, MAX(aft, 1), expnt);
  1427.             put_buffer(work_string,0,'L');
  1428.             break;
  1429.         }
  1430.  
  1431.  
  1432.         /* procedure
  1433.          *   GET(FROM : in STRING; ITEM : out NUM; LAST : out POSITIVE);
  1434.          */
  1435.  
  1436.     case P_GET_FLOAT_STRING:
  1437.         {
  1438.             int     *item_tt_ptr;
  1439.             int     *from_tt_ptr;
  1440.             int     *item_ptr;
  1441.             int     *last_ptr;
  1442.             int     last;
  1443.             float   fval;
  1444.  
  1445.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1446.  
  1447.             get_string_value(0);
  1448.             from_tt_ptr = get_argument_ptr(0);
  1449.             item_ptr =    get_argument_ptr(4);
  1450.             last_ptr =    get_argument_ptr(8);
  1451.  
  1452.             fval = scan_float_string(item_tt_ptr, &last);
  1453.             *((float *)(item_ptr)) = fval;
  1454.             last += string_offset(from_tt_ptr) ;
  1455.             *last_ptr = last;
  1456.             break;
  1457.         }
  1458.  
  1459.  
  1460.         /* procedure PUT(TO   : out STRING;               */
  1461.         /*               ITEM : in NUM;                   */
  1462.         /*               AFT  : in FIELD := DEFAULT_AFT;  */
  1463.         /*               EXP  : in FIELD := DEFAULT_EXP); */
  1464.  
  1465.     case P_PUT_FLOAT_STRING:
  1466.         {
  1467.             int     *to_tt_ptr;
  1468.             int     *to_ptr;
  1469.             int     aft, expnt;
  1470.             int     string_size, slength;
  1471.             float   fitem;
  1472.             char    *c;
  1473.  
  1474.             DISCARD_GENERIC_PARAMETER;
  1475.  
  1476.             to_tt_ptr = get_argument_ptr(0);
  1477.             to_ptr  =   get_argument_ptr(2);
  1478.             fitem   = get_float_argument_value(4);
  1479.             aft     = get_argument_value(6);
  1480.             expnt   = get_argument_value(8);
  1481.  
  1482.             image_float(fitem, 0, MAX(aft, 1), expnt);
  1483.             slength = strlen(work_string);
  1484.  
  1485.             string_size = SIZE(to_tt_ptr);
  1486.             if (slength > string_size) {
  1487.                 predef_raise(LAYOUT_ERROR, "String too long");
  1488.             }
  1489.  
  1490.             c = work_string;
  1491.             while(string_size-- > slength) {
  1492.                 *to_ptr++ = ' ';
  1493.             }
  1494.             while(slength--) {
  1495.                 *to_ptr++ = *c++;
  1496.             }
  1497.             break;
  1498.         }
  1499.  
  1500.  
  1501.         /* type NUM is delta <>;                                       */
  1502.         /* procedure GET(FILE : in FILE_TYPE;  ITEM : out NUM;         */
  1503.         /*                                     WIDTH : in FIELD := 0); */
  1504.         /* procedure GET(ITEM : out NUM;  WIDTH : in FIELD := 0);      */
  1505.  
  1506.     case P_GET_FIXED_FILE_ITEM:
  1507.     case P_GET_FIXED_ITEM:
  1508.         {
  1509.             int     *item_tt_ptr;
  1510.             int     *item_ptr;
  1511.             int     width;
  1512.  
  1513.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1514.  
  1515.             get_file_argument_or_default();
  1516.             check_status(TIO_IN_FILE);
  1517.  
  1518.             item_ptr = get_argument_ptr(0 + file_offset);
  1519.             width = get_argument_value(4 + file_offset);
  1520.  
  1521.             check_status(TIO_IN_FILE);
  1522.  
  1523.             *((long *)(item_ptr)) = scan_fixed(item_tt_ptr, width);
  1524.             break;
  1525.         }
  1526.  
  1527.  
  1528.         /* procedure PUT(FILE   : in FILE_TYPE;              */
  1529.         /*               ITEM   : in NUM;                    */
  1530.         /*               FORE   : in FIELD := DEFAULT_FORE;  */
  1531.         /*               AFT    : in FIELD := DEFAULT_AFT;   */
  1532.         /*               EXP    : in FIELD := DECIMAL_EXP);  */
  1533.  
  1534.         /* procedure PUT(ITEM   : in NUM;                    */
  1535.         /*               FORE   : in FIELD := DEFAULT_FORE;  */
  1536.         /*               AFT    : in FIELD := DEFAULT_AFT;   */
  1537.         /*               EXP    : in FIELD := DEFAULT_EXP);  */
  1538.  
  1539.     case P_PUT_FIXED_FILE_ITEM:
  1540.     case P_PUT_FIXED_ITEM:
  1541.         {
  1542.             int     *item_tt_ptr;
  1543.             long    item;
  1544.             int     fore, aft, expnt;
  1545.  
  1546.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1547.  
  1548.             get_file_argument_or_default();
  1549.             check_status(TIO_OUT_FILE);
  1550.  
  1551.             item = get_long_argument_value(0 + file_offset);
  1552.             fore  = get_argument_value(2 + file_offset);
  1553.             aft   = get_argument_value(4 + file_offset);
  1554.             expnt = get_argument_value(6 + file_offset);
  1555.  
  1556.             image_fixed(item, item_tt_ptr, MAX(fore, 1), MAX(aft, 1), expnt);
  1557.             put_buffer(work_string,0,'L');
  1558.             break;
  1559.         }
  1560.  
  1561.  
  1562.         /* procedure
  1563.          *   GET(FROM : in STRING; ITEM : out NUM; LAST : out POSITIVE);
  1564.          */
  1565.  
  1566.     case P_GET_FIXED_STRING:
  1567.         {
  1568.             int     *item_tt_ptr;
  1569.             int     *from_tt_ptr;
  1570.             int     *item_ptr;
  1571.             int     *last_ptr;
  1572.             int     last;
  1573.  
  1574.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1575.  
  1576.             get_string_value(0);
  1577.             from_tt_ptr = get_argument_ptr(0);
  1578.             item_ptr = get_argument_ptr(4);
  1579.             last_ptr = get_argument_ptr(8);
  1580.  
  1581.             *((long *)(item_ptr)) = scan_fixed_string(item_tt_ptr, &last);
  1582.  
  1583.             last += string_offset(from_tt_ptr)  ;
  1584.             *last_ptr = last;
  1585.             break;
  1586.         }
  1587.  
  1588.  
  1589.         /* procedure PUT(TO   : out STRING;               */
  1590.         /*               ITEM : in NUM;                   */
  1591.         /*               AFT  : in FIELD := DEFAULT_AFT;  */
  1592.         /*               EXP  : in FIELD := DEFAULT_EXP); */
  1593.  
  1594.     case P_PUT_FIXED_STRING:
  1595.         {
  1596.             int     *item_tt_ptr;
  1597.             int     *to_tt_ptr;
  1598.             int     *to_ptr;
  1599.             long    item;
  1600.             int     aft, expnt;
  1601.             char    *c;
  1602.             int     string_size, slength;
  1603.  
  1604.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1605.  
  1606.             to_tt_ptr = get_argument_ptr(0);
  1607.             to_ptr    = get_argument_ptr(2);
  1608.             item = get_long_argument_value(4);
  1609.             aft   = get_argument_value(6);
  1610.             expnt = get_argument_value(8);
  1611.  
  1612.             image_fixed(item, item_tt_ptr, 1, MAX(aft, 1), expnt);
  1613.             string_size = SIZE(to_tt_ptr);
  1614.             slength = strlen(work_string);
  1615.  
  1616.             if (slength > string_size) {
  1617.                 predef_raise(LAYOUT_ERROR, "String too long");
  1618.             }
  1619.  
  1620.             c = work_string;
  1621.             while(string_size-- > slength)
  1622.                 *to_ptr++ = ' ';
  1623.             while(slength--)
  1624.                 *to_ptr++ = *c++;
  1625.             break;
  1626.         }
  1627.  
  1628.  
  1629.         /* type ENUM is(<>);                                     */
  1630.         /* procedure GET(FILE : in FILE_TYPE;  ITEM : out ENUM); */
  1631.         /* procedure GET(ITEM : out ENUM);                       */
  1632.  
  1633.     case P_GET_ENUM_FILE_ITEM:
  1634.     case P_GET_ENUM_ITEM:
  1635.         {
  1636.             int     *item_tt_ptr;
  1637.             int     *item_ptr;
  1638.  
  1639.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1640.  
  1641.             get_file_argument_or_default();
  1642.             check_status(TIO_IN_FILE);
  1643.  
  1644.             item_ptr = get_argument_ptr(0 + file_offset);
  1645.             scan_enum();
  1646.  
  1647.             /*  Check to see if the identifier or character literal read */
  1648.             /*  corresponds to a value of the given enumeration subtype. */
  1649.  
  1650.             *item_ptr = enum_ord(item_tt_ptr, -1, DATA_ERROR);
  1651.             break;
  1652.         }
  1653.  
  1654.  
  1655.         /* procedure PUT(FILE  : in FILE_TYPE;                    */
  1656.         /*               ITEM  : in ENUM;                         */
  1657.         /*               WIDTH : in FIELD    := DEFAULT_WIDTH;    */
  1658.         /*               SET   : in TYPE_SET := DEFAULT_SETTING); */
  1659.  
  1660.         /* procedure PUT(ITEM  : in ENUM;                         */
  1661.         /*               WIDTH : in FIELD    := DEFAULT_WIDTH;    */
  1662.         /*               SET   : in TYPE_SET := DEFAULT_SETTING); */
  1663.  
  1664.     case P_PUT_ENUM_FILE_ITEM:
  1665.     case P_PUT_ENUM_ITEM:
  1666.         {
  1667.             int     *item_tt_ptr;
  1668.             int     item, width, setting;
  1669.             char    *c;
  1670.  
  1671.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1672.  
  1673.             get_file_argument_or_default();
  1674.             check_status(TIO_OUT_FILE);
  1675.  
  1676.             item    = get_argument_value(0 + file_offset);
  1677.             width   = get_argument_value(2 + file_offset);
  1678.             setting = get_argument_value(4 + file_offset);
  1679.  
  1680.             image_enum(item, item_tt_ptr);
  1681.             if (setting == LOWER_CASE && *work_string != QUOTE) {
  1682.                 for (c = work_string; *c; c++)
  1683.                     if ('A' <= *c && *c <= 'Z') *c += 32;
  1684.             }
  1685.             put_buffer(work_string, width, 'T');
  1686.             break;
  1687.         }
  1688.  
  1689.  
  1690.         /* procedure
  1691.          *    GET(FROM : in STRING; ITEM : out ENUM; LAST : out POSITIVE);
  1692.          */
  1693.  
  1694.     case P_GET_ENUM_STRING:
  1695.         {
  1696.             int     *item_tt_ptr;
  1697.             int     *from_tt_ptr;
  1698.             int     *item_ptr;
  1699.             int     *last_ptr;
  1700.             int     last;
  1701.  
  1702.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1703.  
  1704.             get_string_value(0);
  1705.             from_tt_ptr = get_argument_ptr(0);
  1706.             item_ptr    = get_argument_ptr(4);
  1707.             last_ptr    = get_argument_ptr(8);
  1708.  
  1709.             scan_enum_string(&last);
  1710.  
  1711.             /*  Check to see if the identifier or character literal read */
  1712.             /*  corresponds to a value of the given enumeration subtype. */
  1713.  
  1714.             *item_ptr = enum_ord(item_tt_ptr, -1,  DATA_ERROR);
  1715.             last += string_offset(from_tt_ptr) ;
  1716.             *last_ptr = last;
  1717.             break;
  1718.         }
  1719.  
  1720.  
  1721.         /* procedure PUT(TO   : out STRING;                      */
  1722.         /*               ITEM : in ENUM;                         */
  1723.         /*               SET  : in TYPE_SET := DEFAULT_SETTING); */
  1724.  
  1725.     case P_PUT_ENUM_STRING:
  1726.         {
  1727.             int     *item_tt_ptr;
  1728.             int     *to_ptr;
  1729.             int     *to_tt_ptr;
  1730.             int     string_size, slength;
  1731.             int     item;
  1732.             int     setting;
  1733.             char    *c;
  1734.  
  1735.             POP_PTR(item_tt_ptr);      /* pop generic type parameter */
  1736.  
  1737.             to_tt_ptr = get_argument_ptr(0);
  1738.             to_ptr    = get_argument_ptr(2);
  1739.             item    = get_argument_value(4);
  1740.             setting = get_argument_value(6);
  1741.  
  1742.             image_enum(item, item_tt_ptr);
  1743.             if (setting == LOWER_CASE && *work_string != QUOTE) {
  1744.                 for (c = work_string; *c; c++)
  1745.                     if ('A' <= *c && *c <= 'Z') *c += 32;
  1746.             }
  1747.  
  1748.             string_size = SIZE(to_tt_ptr);
  1749.             slength = strlen(work_string);
  1750.  
  1751.             if (slength > string_size) {
  1752.                 predef_raise(LAYOUT_ERROR, "String too long");
  1753.             }
  1754.  
  1755.             to_ptr += string_size;
  1756.             c = work_string + slength;
  1757.             while(string_size-- > slength) {
  1758.                 *--to_ptr = ' ';
  1759.             }
  1760.             while(slength--) {
  1761.                 *--to_ptr = *--c;
  1762.             }
  1763.             break;
  1764.         }
  1765.  
  1766.  
  1767.         /* 9.6  CALENDAR */
  1768.  
  1769.     case P_CLOCK:
  1770.     case P_YEAR:
  1771.     case P_MONTH:
  1772.     case P_DAY:
  1773.     case P_SECONDS:
  1774.     case P_SPLIT:
  1775.     case P_TIME_OF:
  1776.     case P_ADD_TIME_DUR:
  1777.     case P_ADD_DUR_TIME:
  1778.     case P_SUB_TIME_DUR:
  1779.     case P_SUB_TIME_TIME:
  1780.     case P_LT_TIME:
  1781.     case P_LE_TIME:
  1782.     case P_GT_TIME:
  1783.     case P_GE_TIME:
  1784.         {
  1785.             calendar();
  1786.             break;
  1787.         }
  1788.  
  1789.  
  1790.     default:
  1791.         predef_raise(SYSTEM_ERROR, "Unknown PREDEF operation");
  1792.     }
  1793. }
  1794.  
  1795.  
  1796. /* PREDEF_RAISE */
  1797.  
  1798. /* This procedure raises a specified exception, and then exits from the
  1799.  * PREDEF package completely by unwinding the stack to the top level
  1800.  */
  1801.  
  1802. void predef_raise(int exception, char *msg)            /*;predef_raise*/
  1803. {
  1804.     raise(exception, msg);
  1805.     longjmp(raise_env, 1);
  1806. }
  1807.  
  1808. static int string_offset(int *a_ptr)            /*;string_offset*/
  1809. {
  1810.     if (TYPE(a_ptr) == TT_S_ARRAY) {
  1811.         value = S_ARRAY(a_ptr) -> salow ;
  1812.     }
  1813.     else {
  1814.         bse   = ARRAY(a_ptr)->index1_base ;
  1815.         off   = ARRAY(a_ptr)->index1_offset ;
  1816.         ptr1  = ADDR(bse, off) ;
  1817.         value = I_RANGE(ptr1)->ilow ;
  1818.     }
  1819.     return value;
  1820. }
  1821.